home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / CorePackages / windows.tcl < prev    next >
Encoding:
Text File  |  2001-01-24  |  7.5 KB  |  276 lines
  1. #  AlphaTcl - core Tcl engine
  2.  
  3. namespace eval win {}
  4.  
  5. proc win::Current {} {global win::Current ; return ${win::Current}}
  6. proc win::CurrentTail {} {
  7.     global win::Current ; return [file tail ${win::Current}]
  8. }
  9. proc win::TopNonProcessWindow {} {
  10.     global win::Active
  11.     foreach f [set win::Active] {
  12.     if {![regexp {^\* .* \*( <[0-9]+>)?$} $f]} {
  13.         return $f
  14.     }
  15.     }
  16.     return ""
  17. }
  18. proc win::TopFileWindow {} {
  19.     global win::Active
  20.     foreach f [set win::Active] {
  21.     if {[file exists [win::StripCount $f]]} {
  22.         return $f
  23.     }
  24.     }
  25.     return ""
  26. }
  27.  
  28. proc win::StripCount {name} {
  29.     regsub { <[0-9]+>} $name {} name
  30.     return $name
  31. }
  32.  
  33. ## 
  34.  # -------------------------------------------------------------------------
  35.  # 
  36.  # "win::addToMenu" --
  37.  # 
  38.  #  Adds a window name to the window menu.  This new version adds a 
  39.  #  binding, to work-around a bug in Alpha, so that using cmd-0-9
  40.  #  works if the window name contains square brackets.  The problem
  41.  #  is that the 'addMenuItem' line creates a binding of the form
  42.  #  'menu::winProc •263 namewith[square]brackets' which when evaluated
  43.  #  causes an error.  We force a separate binding to
  44.  #  'menu::winProc •263 {namewith[square]brackets}' which does work.
  45.  # -------------------------------------------------------------------------
  46.  ##
  47. proc win::addToMenu {name} {
  48.     global winNameToNum winMenu winNumToName
  49.     if {[info tclversion] < 8.0} {
  50.     set name [subst $name]
  51.     }
  52.     
  53.     for {set i 0} {$i<100} {incr i} {
  54.     if {![info exists winNumToName($i)]} {
  55.         regsub { <[0-9]+>$} $name {} nm
  56.         if {[file exists $nm]} {
  57.         set nm [file tail $name]
  58.         } else {
  59.         set nm $name
  60.         }
  61.         if {$i < 10} {
  62.         addMenuItem -m -l "/$i" $winMenu "$nm"
  63.         if {[info tclversion] < 8.0} {
  64.             Bind '$i' <c> [list menu::winProc $winMenu $nm]
  65.         }
  66.         } else {
  67.         addMenuItem -m -l "" $winMenu "$nm"
  68.         }
  69.         set winNumToName($i) $name
  70.         set winNameToNum($name) $i
  71.         return
  72.     }
  73.     }
  74. }
  75.  
  76. proc win::removeFromMenu {name} {
  77.     global winNameToNum winNumToName winMenu
  78.     if {[info tclversion] < 8.0} {
  79.     set name [subst $name]
  80.     }
  81.     set num $winNameToNum($name)
  82.     unset winNumToName($num)
  83.     unset winNameToNum($name)
  84.     regsub { <[0-9]+>$} $name {} nm
  85.     if {[file exists $nm]} {
  86.     set nm [file tail $name]
  87.     } else {
  88.     # in case it was a file but the file was actually moved!
  89.     global file::separator tcl_platform
  90.     if {[regexp "\[^${file::separator}\]+\$" $name nm]} {
  91.         if {![catch {deleteMenuItem -m $winMenu $nm}]} { return } 
  92.     }
  93.     if {$tcl_platform(platform) == "windows"} {
  94.         if {[regexp "\[^\\\\\]+\$" $name nm]} {
  95.         if {![catch {deleteMenuItem -m $winMenu $nm}]} { return } 
  96.         }
  97.     }
  98.     set nm $name
  99.     }
  100.     # to handle alpha problem with rebuilding the menu
  101.     if {[catch {deleteMenuItem -m $winMenu $nm}]} { 
  102.     deleteMenuItem $winMenu $nm 
  103.     }
  104. }
  105.  
  106. ## 
  107.  # -------------------------------------------------------------------------
  108.  #     
  109.  # "win::setMode" --
  110.  #    
  111.  #  Copes with endings like '.orig' or the backup ending '~' or '
  112.  #  copy'.
  113.  #
  114.  # -------------------------------------------------------------------------
  115.  ##
  116. proc win::setMode name {
  117.     global win::Modes
  118.     set win::Modes($name) [win::FindMode $name]
  119. }
  120.  
  121. ## 
  122.  # -------------------------------------------------------------------------
  123.  # 
  124.  # "win::setInitialMode" --
  125.  # 
  126.  #  Only to be called the very first time we set a window's mode, since
  127.  #  it may have all sorts of side-effects.
  128.  # -------------------------------------------------------------------------
  129.  ##
  130. proc win::setInitialMode {winname mode} {
  131.     global win::Modes
  132.     set win::Modes($winname) $mode
  133.     
  134.     global tabSize ${mode}modeVars
  135.     if {[info exists ${mode}modeVars(tabSize)]} {
  136.     # The mode that the new window will open up in
  137.     # has its own value for tabSize
  138.     win::setInitialConfig $winname tabsize [set ${mode}modeVars(tabSize)]]
  139.     }
  140.  
  141.     # If someone wants a hook here for some reason, please ask!
  142.     #hook::callAll initialModeSetHook $mode $winname
  143. }
  144.  
  145. proc win::setInitialConfig {winname option value} {
  146.     global win::config
  147.     lappend win::config($winname) [list $option $value]
  148. }
  149.  
  150. ## 
  151.  # -------------------------------------------------------------------------
  152.  # 
  153.  # "win::FindMode" --
  154.  # 
  155.  #  Copes with trailing '<2>', .orig, copy, '~',...
  156.  # -------------------------------------------------------------------------
  157.  ##
  158. proc win::FindMode {name} {
  159.     global ModeSuffixes
  160.     regsub { <[0-9]+>$} $name "" nm
  161.     regsub {( copy|~[0-9]*|.orig|.in)+$} [file tail $nm] "" nm
  162.     case $nm in $ModeSuffixes
  163.     return $winMode
  164. }
  165.  
  166. if {![llength [info commands win::Encoding]]} {
  167. proc win::Encoding {args} {
  168.     switch -- [llength $args] {
  169.     0 {
  170.         return "macRoman"
  171.     }
  172.     1 {
  173.         # encoding of 'name = [lindex $args 0]'
  174.         return "macRoman"
  175.     }
  176.     2 {
  177.         # set encoding of [lindex $args 0] to [lindex $args 1]
  178.         # not implemented in Alpha 7 or 8 yet.
  179.         return ""
  180.     }
  181.     default {
  182.         error "Wrong number of arguments"
  183.     }
  184.     }
  185. }
  186.  
  187. }
  188.  
  189. ## 
  190.  # ----------------------------------------------------------------------
  191.  #     
  192.  #  "win::searchAndHyperise" --
  193.  #    
  194.  #  Scans through an entire file for a particular string or regexp, and
  195.  #  attaches a hyperlink of the specified form (regsub'ed if desired)
  196.  #  to the original string.
  197.  #            
  198.  #    Side effects:
  199.  #     Many hyperlinks will be embedded in your file
  200.  #    
  201.  #    Arguments:
  202.  #     Look for 'text', replace with 'link', doing both with a regexp
  203.  #     if signified (regexp = 1), using colour 'col', and offsetting
  204.  #     the link start and end by 'startoff' and 'endoff' respectively.
  205.  #     This last bit is so you can search for a large pattern, but only
  206.  #     embed a link in a smaller part of it.
  207.  #     
  208.  #    Examples: 
  209.  #     see 'proc install::hyperiseUrls'
  210.  # ----------------------------------------------------------------------
  211.  ##
  212. proc win::searchAndHyperise {text link {regexp 0} {col 3} {startoff 0} {endoff 0}} {
  213.     set pos [minPos]
  214.     catch {
  215.     while 1 {
  216.         set inds [search -s -f 1 -r $regexp -- $text $pos]
  217.         set from [lindex $inds 0]
  218.         set to [lindex $inds 1]
  219.         set realfrom $from
  220.         set realto $to
  221.         set realfrom [pos::math $realfrom + $startoff]
  222.         set realto [pos::math $realto + $endoff]
  223.         text::color $realfrom $realto $col
  224.         if {$link != ""} {
  225.         if {$regexp} {
  226.             regsub -- $text [getText $from $to] "$link" llink
  227.         } else {
  228.             set llink $link
  229.         }
  230.         # hack to handle some links.
  231.         regsub -- "<<" $llink "" llink
  232.         regsub -- ">>" $llink "" llink
  233.         if {[pos::diff $realfrom $realto] < 100} {
  234.             text::hyper $realfrom $realto $llink
  235.         } else {
  236.             # Should turn this into an error in the future.
  237.             message "Tried to mark very large hyper."
  238.         }
  239.         }
  240.         set pos $to
  241.     }    
  242.     }
  243.     refresh
  244. }
  245. proc win::multiSearchAndHyperise {args} {
  246.     while 1 {
  247.     set text [lindex $args 0]
  248.     set link [lindex $args 1]
  249.     set args [lrange $args 2 end]
  250.     if {$text == ""} {return}
  251.     win::searchAndHyperise $text $link
  252.     }
  253. }
  254.  
  255. ## 
  256.  # -------------------------------------------------------------------------
  257.  # 
  258.  # "win::jumpToCode" --
  259.  # 
  260.  #  It creates a hyperlink to a specific string in a code file, without
  261.  #  requiring a mark to be defined there. It was handy for identifying places 
  262.  #  in other packages that potentially collide with my key-bindings.
  263.  #  
  264.  #  Author: Jon Guyer.
  265.  # -------------------------------------------------------------------------
  266.  ##
  267. proc win::jumpToCode {text file code} {
  268.     set hyper {edit -c }
  269.     append hyper $file
  270.     append hyper { ; set pos [search -f 1 -r 1 "}
  271.     append hyper $code
  272.     append hyper {"] ; select [lindex $pos 0] [lindex $pos 1]}
  273.     win::searchAndHyperise $text $hyper 0 3
  274. }
  275.  
  276.